home *** CD-ROM | disk | FTP | other *** search
/ BBS Toolkit / BBS Toolkit.iso / doors_2 / prok345.zip / PROCS.DOC < prev    next >
Text File  |  1991-04-01  |  15KB  |  528 lines

  1.  
  2. (*
  3.  * Copyright 1987, 1989 Samuel H. Smith;  All rights reserved
  4.  *
  5.  * This is a component of the ProDoor System.
  6.  * Do not distribute modified versions without my permission.
  7.  * Do not remove or alter this notice or any other copyright notice.
  8.  * If you use this in your own program you must distribute source code.
  9.  * Do not use any of this in a commercial product.
  10.  *
  11.  *)
  12.  
  13.  
  14. =======================================================================
  15. MiniCrt unit
  16. ------------
  17. (*
  18.  * MiniCrt - simplified version of Borland's CRT unit.
  19.  * Does not EVER do direct video.  The standard crt unit
  20.  * locks up multi-taskers with its direct video checking before
  21.  * the user program can turn it off.
  22.  * (3-1-89)
  23.  *)
  24.  
  25.    var
  26.       stdout:  text;  (* output through dos for ANSI compatibility *)
  27.  
  28.    function KeyPressed: Boolean;
  29.    function ReadKey: Char;
  30.  
  31.    procedure SetScrollPoint(Y2: Byte);
  32.    procedure FullScreen;
  33.  
  34.    procedure GotoXY(X,Y: Byte);
  35.    function WhereX: Byte;
  36.    function WhereY: Byte;
  37.  
  38.    procedure ClrScr;
  39.    procedure ClrEol;
  40.  
  41.    procedure NormalVideo;
  42.    procedure LowVideo;
  43.    procedure ReverseVideo;
  44.    procedure BlinkVideo;
  45.  
  46.  
  47. =======================================================================
  48. BufIO unit
  49. ----------
  50. (*
  51.  * Bufio - Buffered File I/O Unit (3-1-89)
  52.  *
  53.  * This unit provides both read and write buffering on block oriented
  54.  * random-access files.  It is optimized for sequential reads or writes,
  55.  * but will function properly with fully random files.
  56.  *
  57.  *)
  58.  
  59.    type
  60.       buffered_file = private;
  61.  
  62.    var
  63.       berr: boolean;       (* true if buffered read or write fails *)
  64.  
  65.    procedure bcreate(name:    dos_filename);
  66.       (* create an empty file; use with bopen to open output files *)
  67.  
  68.    procedure bopen(var bfd:   buffered_file; (* file variable *)
  69.                    name:      dos_filename;  (* name of file *)
  70.                    maxrecn:   word;          (* number of records to buffer *)
  71.                    recsize:   word);         (* size of each record *)
  72.       (* open a buffered file *)                 (* sets 'bErr' if not ok *)
  73.  
  74.    procedure bflush(var bfd:  buffered_file);
  75.       (* write buffer, force re-read on next access *)
  76.       
  77.    procedure bseek(var bfd:   buffered_file;
  78.                    recn:      word);
  79.       (* set position of buffered file *)
  80.    
  81.    procedure bseekeof(var bfd:   buffered_file);
  82.       (* set position of buffered file to end-of-file *)
  83.    
  84.    function btell(var bfd:    buffered_file): word;
  85.       (* tell current record number in buffered file *)
  86.  
  87.    function beof(var bfd:     buffered_file): boolean;
  88.       (* check for eof on buffered file *)
  89.  
  90.    procedure bread(var bfd:   buffered_file;
  91.                    var dest);
  92.       (* buffered read *)
  93.    
  94.    procedure bwrite(var bfd:   buffered_file;
  95.                     var src);
  96.       (* buffered write *)
  97.  
  98.    procedure bclose(var bfd:  buffered_file);
  99.       (* close a buffered file *)
  100.  
  101.  
  102. =======================================================================
  103. MdosIO unit
  104. -----------
  105. (*
  106.  * mdosio - library for interface to DOS v3 file access functions (3-1-89)
  107.  *
  108.  *)
  109.  
  110.    type
  111.       dos_filename = string[64];
  112.       dos_handle   = word;
  113.  
  114.       seek_modes = (seek_start {0},     (* seek relative to start of file *)
  115.                     seek_cur   {1},     (* seek from current position *)
  116.                     seek_end   {2});    (* seek from end of file *)
  117.  
  118.       open_modes = (open_read  {h40},   (* deny_nothing, allow_read *)
  119.                     open_write {h41},   (* deny_nothing, allow_write *)
  120.                     open_update{h42});  (* deny_nothing, allow_read+write *)
  121.  
  122.    const
  123.       dos_error    = $FFFF; (* file handle after an error *)
  124.  
  125.    var
  126.       dos_regs:     registers;
  127.       dos_name:     dos_filename;
  128.  
  129.  
  130.    function dos_open(name:      dos_filename;
  131.                      mode:      open_modes):  dos_handle;
  132.  
  133.    function dos_create(name:    dos_filename): dos_handle;
  134.  
  135.    function dos_read( handle:   dos_handle;
  136.                       var       buffer;
  137.                       bytes:    word): word;
  138.  
  139.    procedure dos_write(handle:  dos_handle;
  140.                        var      buffer;
  141.                        bytes:   word);
  142.  
  143.    function dos_write_failed:   boolean;
  144.  
  145.    procedure dos_lseek(handle:  dos_handle;
  146.                        offset:  longint;
  147.                        method:  seek_modes);
  148.  
  149.    procedure dos_rseek(handle:  dos_handle;
  150.                        recnum:  word;
  151.                        recsiz:  word;
  152.                        method:  seek_modes);
  153.  
  154.    function dos_tell: longint;
  155.  
  156.    procedure dos_find_eof(fd:   dos_handle);
  157.  
  158.    procedure dos_close(handle:  dos_handle);
  159.  
  160.    procedure dos_unlink(name:   dos_filename);
  161.  
  162.    function dos_exists(name: dos_filename): boolean;
  163.  
  164.  
  165. =======================================================================
  166. DosMem unit
  167. -----------
  168. (*
  169.  * dosmem - Dos Memory Management Unit (3-1-89)
  170.  *
  171.  * This unit allocates memory via DOS so you don't have to reserve
  172.  * heap space in advance.
  173.  *
  174.  *)
  175.  
  176.    function dos_maxavail: longint;
  177.    procedure dos_getmem(var ptrvar; size: word);
  178.    procedure dos_freemem(var ptrvar);
  179.  
  180.  
  181. =======================================================================
  182. Tools Unit
  183. ----------
  184. (*
  185.  * Tools - this unit provides a variety of utility functions
  186.  *         based on the Tool Shop "TOOL-INC" library.
  187.  *
  188.  *)
  189.  
  190. (* --------------------------------------
  191.  * various string and character types
  192.  *)
  193.  
  194. type
  195.    filenames  = string[namesizes];
  196.    anystring  = string[128];
  197.    longstring = string[255];
  198.    string2   = string[2];
  199.    string8   = string[8];
  200.    string10  = string[10];
  201.    string12  = string[12];
  202.    string13  = string[13];
  203.    string20  = string[20];
  204.    string25  = string[25];
  205.    string30  = string[30];
  206.    string40  = string[40];
  207.    string65  = string[65];
  208.    string72  = string[72];
  209.    string80  = string[80];
  210.    string160 = string[160];
  211.    string255 = string[255];
  212.    char2  = array[1..2] of char;
  213.    char3  = array[1..3] of char;
  214.    char4  = array[1..4] of char;
  215.    char5  = array[1..5] of char;
  216.    char6  = array[1..6] of char;
  217.    char7  = array[1..7] of char;
  218.    char8  = array[1..8] of char;
  219.    char9  = array[1..9] of char;
  220.    char10 = array[1..10] of char;
  221.    char11 = array[1..11] of char;
  222.    char12 = array[1..12] of char;
  223.    char13 = array[1..13] of char;
  224.    char14 = array[1..14] of char;
  225.    char15 = array[1..15] of char;
  226.    char16 = array[1..16] of char;
  227.    char19 = array[1..19] of char;
  228.    char24 = array[1..24] of char;
  229.    char25 = array[1..25] of char;
  230.    char30 = array[1..30] of char;
  231.    char39 = array[1..39] of char;
  232.    char40 = array[1..40] of char;
  233.    char32 = array[1..32] of char;
  234.    char35 = array[1..35] of char;
  235.    char45 = array[1..45] of char;
  236.    char128 = array[1..128] of char;
  237.  
  238.  
  239. (* --------------------------------------
  240.  * mult-tasker support
  241.  *)
  242. const
  243.    tasker:  (taskview,                  (* taskview/omniview/topview/desqview *)
  244.              doubledos,                 (* doubledos *)
  245.              notasker,                  (* single task *)
  246.              unknown) = unknown;        (* before first call *)
  247.  
  248. procedure determine_tasker;     (* determine what multi-tasker is active, if any *)
  249.  
  250. procedure give_up_time;         (* give up unused time under doubledos *)
  251.  
  252. procedure delay(ms: longint);
  253.    (* delay for a specified number of miliseconds;
  254.       give up time while delaying *)
  255.  
  256.  
  257. (* --------------------------------------
  258.  * bit-set support
  259.  *)
  260. const
  261.    maxbit = 40;
  262. type
  263.    bitnumber = 0..39;
  264.    bitmap = record
  265.       bits:  array[0..4] of byte;       (* bits 0..39 *)
  266.    end;
  267.  
  268. procedure setbit(var map: bitmap; bitnum: bitnumber; value: boolean);
  269.    (* set the specified bit in a bitmap *)
  270.  
  271. function getbit(map: bitmap; bitnum: bitnumber): boolean;
  272.    (* return true/false for specified bit in a bitmap *)
  273.  
  274.  
  275. (* --------------------------------------
  276.  * byte flag support
  277.  *)
  278.  
  279. function getflag(flag: byte; bitval: byte): boolean;
  280.    (* return true/false for specified is set *)
  281.  
  282. procedure setflag(var flag: byte; bitval: byte; value: boolean);
  283.    (* set the specified bit in a flagbyte *)
  284.  
  285.  
  286. (* --------------------------------------
  287.  * wildcard and filelist support
  288.  *)
  289.  
  290. const
  291.    maxnumfiles =  200;
  292.    null =         #0;
  293. type
  294.    filearray =    array [1.. maxnumfiles] of varstring;
  295. var
  296.    filetable:     filearray;
  297.    filecount:     integer;
  298.  
  299. procedure getfiles (pattern:       string65;
  300.                     var fdir:      filearray;
  301.                     var num:       integer);
  302.  
  303. function is_wild(filename: string65): boolean;
  304.    (* determing if a filespec contains wildcards *)
  305.  
  306. function wildcard_match (var pattern,
  307.                          line:               string65): boolean;
  308.    (* pattern must be upper case; line is not case sensitive;
  309.       returns true if wildcard pattern matches line *)
  310.  
  311.  
  312. (* --------------------------------------
  313.  * filename manipulation utilities
  314.  *)
  315.  
  316. function dir_only(name: filenames): filenames;
  317.    (* return directory portion of a full filename *)
  318.  
  319. function ext_only(name: filenames): filenames;
  320.    (* return .EXT portion of a full filename *)
  321.  
  322. function file_size(name: string65): longint;
  323.    (* return the actual size of a file *)
  324.  
  325. function path_only(name: filenames): filenames;
  326.    (* return directory portion of a filename with trailing "\" *)
  327.  
  328. function remove_ext(name: filenames): filenames;
  329.    (* return all except .EXT *)
  330.  
  331. function remove_path(name: filenames): filenames;
  332.    (* return all except drive:\directory prefix *)
  333.  
  334. procedure cons_name(var resu:          filenames;
  335.                     name1,name2,ext:   filenames);
  336.    (* construct a full filename based on the given filename
  337.       parts and extention *)
  338.  
  339. procedure cons_path(var path: filenames;
  340.                     dir,name: filenames);
  341.    (* construct a full pathname based on a directory and filename *)
  342.  
  343.  
  344. (* --------------------------------------
  345.  * variable allocation string support
  346.  *)
  347.  
  348. type
  349.    varstring = ^longstring;
  350.  
  351. (* NOTE: you must pre-initialize all varstring variables to 'nil'
  352.          before using any procedure in this library *)
  353.  
  354. procedure releasestr( var str:  varstring);
  355.    (* release the memory used by a varstring variable.  variable MUST
  356.       be pre-allocated or the program may crash!!! *)
  357.  
  358. procedure savestr( var tostr: varstring;
  359.                    from:      longstring);
  360.    (* save a regular string in a varstring; new allocation of varstring *)
  361.  
  362. procedure vappends(var line: varstring; s: anystring);
  363.    (* append a string to a variable allocation string *)
  364.  
  365.  
  366. (* --------------------------------------
  367.  * "basic" format 'single' and 'double' conversions
  368.  *)
  369.  
  370. type
  371.   double    = array[0..7] of byte;
  372.   single    = array[0..3] of byte;
  373.  
  374. function dtof(B: double): real;
  375.    (* convert 8 byte double to real *)
  376.  
  377. procedure ftod(PasReal: real; var B: double);
  378.    (* convert real to 8 byte double *)
  379.  
  380. function dtol(B: double): longint;
  381.    (* convert 8 byte double to long integer *)
  382.  
  383.  
  384. function stof(B: single): real;
  385.    (* convert 4 byte single to real *)
  386.  
  387. procedure ftos(PasReal: real; var B: single);
  388.    (* convert real to 4 byte single *)
  389.  
  390. procedure ltos(l: longint; var B: single);
  391.  
  392. function stol(s: single): longint;
  393.  
  394. procedure zeros(var B: single);
  395.  
  396. procedure incd(var d: double; n: real);
  397.  
  398. procedure incs(var s: single; n: real);
  399.  
  400.  
  401.  
  402. (* --------------------------------------
  403.  * ascii to binary conversions
  404.  *)
  405.  
  406. function atof (asc:  anystring): real;
  407.    (* ascii to float *)
  408.  
  409. function atoi (asc:  anystring): integer;
  410.    (* ascii to signed integer *)
  411.  
  412. function atol (asc:  anystring): longint;
  413.    (* ascii to long integer *)
  414.  
  415. function atow (asc:  anystring): word;
  416.    (* ascii to unsigned integer *)
  417.  
  418.  
  419. (* --------------------------------------
  420.  * binary to ascii conversions
  421.  *)
  422.  
  423. function ltoa (int: longint): string8;
  424.    (* long integer to ascii *)
  425.  
  426. function stoa(s: single): string10;
  427.    (* "basic" single to ascii *)
  428.  
  429. function ftoa(f: real; width,dec: integer): string20;
  430.    (* floating point to ascii *)
  431.  
  432. function itoa (int: integer): string8;
  433.    (* integer to ascii *)
  434.  
  435. function itoh(i: longint): string8;
  436.    (* integer to hex digits *)
  437.  
  438. function wtoa (w: word): string8;
  439.    (* unsigned integer to ascii *)
  440.  
  441. function strval (i: integer): string2;
  442.    (* return 2 digits from an integer; leading zero provided
  443.       if needed; used to build date/time strings *)
  444.  
  445.  
  446. (* --------------------------------------
  447.  * real-time clock support
  448.  *)
  449.  
  450. function get_mins: integer;
  451.    (* return time in minutes since midnight *)
  452.  
  453. function get_time: real;
  454.    (* return time in seconds since midnight *)
  455.  
  456. function lget_ms: longint;
  457.    (* return time in seconds*100 since midnight *)
  458.  
  459. function lget_time: longint;
  460.    (* return time in seconds since midnight *)
  461.  
  462. function system_time: string8;
  463.    (* return time of day as hh:mm *)
  464.  
  465. function system_date: string8;
  466.    (* return current date as mm-dd-yy *)
  467.  
  468. function system_dd: string2;
  469.    (* return day of month *)
  470.  
  471. function system_mm: string2;
  472.    (* return month number *)
  473.  
  474. function system_yy: string2;
  475.    (* return year *)
  476.  
  477.  
  478. (* --------------------------------------
  479.  * string formatting and manipulation
  480.  *)
  481.  
  482. function ljust(s: string80; w: integer): string80;
  483.    (* left justify a string *)
  484.  
  485. function rjust(s: string80; w: integer): string80;
  486.    (* right justify a string *)
  487.  
  488. procedure delete_leading_spaces(var line: string);
  489. procedure delete_trailing_spaces(var line: string);
  490.    (* remove spaces from front or back of a string *)
  491.  
  492. procedure replace_string( var line: longstring; oldstr, newstr: string65);
  493.    (* perform string replacement if possible *)
  494.  
  495. procedure stoupper(var st: string);
  496.    (* map a string to upper case *)
  497.  
  498.  
  499. =======================================================================
  500. qRead unit
  501. ----------
  502. (*
  503.  * QRead - Quick ReadLn Unit for Strings
  504.  *
  505.  *)
  506.  
  507.    procedure qReadLn( var fd: text;       {text file to read from}
  508.                       var dest: string;   {destination string}
  509.                       maxlen: word );     {sizeof dest string}
  510.  
  511.  
  512. =======================================================================
  513. OpenShare unit
  514. --------------
  515. (*
  516.  * OpenShare - TPAS 5.0 unit for shared text files (3-1-89)
  517.  *
  518.  * Use AssignText instead of Assign to create a text file
  519.  * with full DOS 3.x file sharing (as implemented for binary
  520.  * files by MDosIO)
  521.  *
  522.  *)
  523.  
  524.    procedure AssignText(var F:  Text; FileName:  dos_filename);
  525.       (* use instead of Assign() for shared text files *)
  526.  
  527.  
  528.